home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d3 / wrdhplj.arc / SOFTREAD.PAS < prev    next >
Pascal/Delphi Source File  |  1989-04-14  |  18KB  |  516 lines
  1.  
  2. Program Softread;                        {version 1.2  July 13, 1988}
  3.                                          {copyright 1988, David K Fibush}
  4. Uses   DOS, CRT, Printer;
  5.  
  6. Type
  7.    A3B = Array[1..3] of byte;
  8.    A6B = Array[1..6] of byte;
  9.    A512B = Array[0..511] of Byte;
  10.    A2048B = Array[0..2047] of byte;
  11.    S4  = String[4];
  12.    S12 = String[12];
  13.    A256S8 = Array[0..255] of String[8];
  14.  
  15. Var
  16.    InFile : File of byte;                  {Input file is bytes}
  17.    OutFile : Text;                         {Output file is text}
  18.    FD : A512B;                             {Font Descriptor}
  19.    CD : A2048B;                            {Character Data can get very large}
  20.    EndofFile : Boolean;                    {End of file reached}
  21.    EndofData : Boolean;                    {No further char data found}
  22.    GoodData : Boolean;                     {Good character data found}
  23.    Error : Boolean;                        {Error in finding data}
  24.    Size : real;                            {Number of bytes read}
  25.    WidthData : A256S8;                     {Width table data}
  26.    FirstChar : integer;                    {First character in width table}
  27.    LastChar : integer;                     {Last character in width table}
  28.  
  29. Function Exist(TestFile : S12) : boolean;  {Test to see if file exists}
  30.   Var
  31.     Fil : file;
  32.   Begin
  33.     Assign(Fil, TestFile);                 {Assign filename to variable}
  34.     {$I-}                                  {Turn off error checking}
  35.     Reset(Fil);                            {Attempt to reset file}
  36.     {$I+}                                  {Turn on error checking}
  37.     Exist := (IOresult = 0);               {Exists true if IOresult = 0}
  38.   end;
  39.  
  40. Procedure OpenFiles;                      {requests filename and opens file}
  41. Var
  42.    FileName : String[14];
  43. Begin
  44.    EndofFile := false;
  45.    Write('Font File                 '); Readln(FileName);
  46.    If NOT Exist(FileName)
  47.       Then
  48.          Begin
  49.             Writeln('The file does not exist');
  50.             Halt;                         {Stops program with error message}
  51.          end;
  52.    Assign(InFile, FileName);              {Assign filename to variable}
  53.    Reset(InFile);                         {Start at begining of file}
  54. End; {OpenFiles}
  55.  
  56. Function NextByte : Byte;                 {reads next byte from the file}
  57. Var
  58.    OneByte : byte;
  59. Begin
  60.    If NOT Eof(InFile) Then
  61.       Begin
  62.          Read(InFile,OneByte);            {reads one byte}
  63.          NextByte := OneByte;             {assigns value to function}
  64.          Size := Size + 1                 {increments size}
  65.       end {if}
  66.       Else
  67.          Begin
  68.             EndofFile := true;            {sets flag}
  69.          end; {else}
  70. End; {NextByte}
  71.  
  72.  
  73. Function DataSize(TermChar : Char) : Integer;
  74.  
  75. {With the file pointer positioned at the start of the bytes defining data
  76.  size this function will determine the decimal data size by looking for
  77.  the terminating character and calculating the value defined by the
  78.  interveaning bytes}
  79.  
  80. Var
  81.    DataByte : byte;
  82.    ByteNum : Integer;                     {Current byte number}
  83.    NumofBytes : Integer;                  {Number of bytes in data size}
  84.    DecVal, Total, X, Y : Integer;
  85.    HexData : A6B;
  86. Begin
  87.    ByteNum := 1;
  88.    DataByte := NextByte;                  {read next byte}
  89.  
  90. {Find terminating character and fill the Hex data array, 7 bytes maximum}
  91.  
  92.    While  (Chr(DataByte) <> TermChar) AND (ByteNum < 8) do
  93.       Begin
  94.          HexData[ByteNum] := DataByte;    {assign byte to data array}
  95.          DataByte := NextByte;            {next byte}
  96.          ByteNum := ByteNum + 1;          {increment current byte number}
  97.       end;  {of While}
  98.  
  99.    If ByteNum <  8 then                   {found correct character}
  100.       Begin
  101.          Total := 0;
  102.          NumofBytes := ByteNum -1;        {number of data bytes}
  103.                                       {last was due to reading the TermChar}
  104.  
  105.          For X := NumofBytes downto 1 do  {start with least significant}
  106.             Begin
  107.                DecVal := HexData[X] - 48; {convert Hex to decimal character}
  108.                Y := NumofBytes - X;
  109.                Case Y of
  110.                    0 : Total := Total + DecVal;
  111.                    1 : Total := Total + 10 * DecVal;
  112.                    2 : Total := Total + 100 * DecVal;
  113.                    3 : Total := Total + 1000 * DecVal;
  114.                    4 : Total := Total + 10000 * DecVal;
  115.                 End  {of Case}
  116.            End;  {of For}
  117.            DataSize := Total;             {assign value to the function}
  118.         end
  119.      Else                         {too many bytes with out finding TermChar}
  120.         Begin
  121.            DataSize := 0;
  122.            Error := true;
  123.         end;
  124. End; {of function DataSize}
  125.  
  126.  
  127. Procedure FindCmd (CmdStr : S4);          {Looks for the command string}
  128.                                           {returns error if not found}
  129. Var
  130.    NewStr : String[4];                    {String being read}
  131.    Counter : Integer;
  132.    CmdLen : Integer;                      {Calculated length of command}
  133.    ReadByte : Byte;
  134. Begin
  135.    Counter := 0;
  136.    ReadByte := NextByte;
  137.    While (ReadByte <> 27) AND (Counter < 8) do   {Look for escape, try 7 bits}
  138.       Begin
  139.          ReadByte := NextByte;
  140.          Counter := Counter + 1;
  141.       end;
  142.    If Counter < 8                         {Escape, 1B hex, 27 decimal, found}
  143.       Then
  144.          Begin
  145.             CmdLen := Length(CmdStr);
  146.             NewStr := '';
  147.             For Counter := 1 to CmdLen do NewStr := NewStr + Chr(NextByte);
  148.             If NewStr <> CmdStr then Error := true   {Error, wrong command}
  149.          end
  150.       Else Error := true;                 {Error, escape not found}
  151. end;
  152.  
  153.  
  154. Function FDW(FirstByte : integer) : integer;  {calc word value of 2 FD bytes}
  155. Begin
  156.    FDW := (256 * FD[FirstByte]) + FD[FirstByte + 1];
  157. End;
  158.  
  159. Function CDW(FirstByte : integer) : integer;  {calc word value of 2 CD bytes}
  160. Begin
  161.    CDW := (256 * CD[FirstByte]) + CD[FirstByte + 1];
  162. End;
  163.  
  164.  
  165. Procedure Descriptor;                      {Display font descriptor info}
  166. Var
  167.    ReadByte : Byte;
  168.    Counter : Integer;
  169.    DecFD : Integer;                        {decimal value of font desc length}
  170.    Temp : String[20];
  171.    Term, Field : String[4];               {symbol set terminating char, field}
  172.    Ss : integer;                           {sym set value}
  173.    Calc : real;
  174. Begin
  175.    FindCmd(')s');                          {Look for Font Descriptor command}
  176.    If Error
  177.       then
  178.         begin
  179.            writeln('Font Descriptor command not found');
  180.            Halt;                           {Stops program with error message}
  181.         end; {if}
  182.  
  183.    DecFD := DataSize('W');                 {Find Font Descriptor data size}
  184.       If NOT Error then
  185.          Begin
  186.            Writeln('Font Descriptor Length    ',DecFD,' bytes');
  187.          end
  188.       Else
  189.          Begin
  190.             Writeln('Font Descriptor length not found');
  191.             Halt;                          {Stops program with error message}
  192.          end;
  193.  
  194.    For Counter := 0 to (DecFD - 1) do      {Fill font descriptor array}
  195.       FD[Counter] := NextByte;
  196.  
  197.    {Process and display each byte or word of the font descriptor}
  198.  
  199.    Writeln('Font Descriptor Size      ',FDW(0));
  200.  
  201.    Case FD[3] of
  202.         0 : Temp := '7-bit';
  203.         1 : Temp := '8-bit';
  204.         2 : Temp := 'PC-8';
  205.         else Temp := 'Unknown'
  206.    end; {case}
  207.    Writeln('Font Type                 ',Temp);
  208.  
  209.    Writeln('Baseline Distance         ',FDW(6),' dots');
  210.    Writeln('Cell Width                ',FDW(8),' dots');
  211.    Writeln('Cell Height               ',FDW(10),' dots');
  212.  
  213.    Case FD[12] of
  214.         0 : Temp := 'Portrait';
  215.         1 : Temp := 'Landscape';
  216.         else Temp := 'Unknown';
  217.    end;
  218.    Writeln('Orientation               ',Temp);
  219.  
  220.    Case FD[13] of
  221.         0 : Temp := 'Fixed';
  222.         1 : Temp := 'Proportional';
  223.         else Temp := 'Unknown';
  224.    end;
  225.    Writeln('Spacing                   ',Temp);
  226.  
  227.    Ss := FDW(14);
  228.    Case Ss of
  229.         1 : Temp := 'HP Math-7';
  230.         2 : Temp := 'HP Line Draw';
  231.       269 : Temp := 'HP Math-8';
  232.        21 : Temp := 'ISO 6 ASCII';
  233.        53 : Temp := 'HP Legal';
  234.       277 : Temp := 'HP Roman-8';
  235.       341 : Temp := 'PC-8';
  236.       373 : Temp := 'PC-8 D/N';
  237.       501 : Temp := 'HP Pi Font';
  238.         else Temp := 'Not Listed';
  239.    end;
  240.    Term := Chr(Ss mod 32 + 64);
  241.    Str(SS div 32,Field);
  242.    Writeln('Symbol Set                ',Temp,' PCL:',Field,Term);
  243.  
  244.    If FD[13] = 0 then                     {Only show pitch for fixed-spacing}
  245.       Begin
  246.    Calc := 300/(FDW(16)/4);
  247.    Writeln('Pitch                     ',FDW(16),' ¼dots, ',Calc:4:2,' ch/in');
  248.       end
  249.       Else
  250.    Writeln('Pitch                     ',FDW(16),' ¼dots');
  251.  
  252.    Calc := ((FDW(18)/4)/300)*72;
  253.    Writeln('Height                    ',FDW(18),' ¼dots, ',Calc:4:2,' points');
  254.  
  255.    Case FD[23] of
  256.         0 : Temp := 'Upright';
  257.         1 : Temp := 'Italic';
  258.         else Temp := 'Unknown';
  259.    end;
  260.    Writeln('Style                     ',Temp);
  261.  
  262.    Case FD[24] of
  263.         0 : Temp := 'Normal';
  264.         3 : Temp := 'Bold';
  265.     -7..-1, 2, 4..7 : Temp := '(0=normal, 3=bold)';
  266.         else Temp := 'Unknown, weights are -7 to +7';
  267.    end;
  268.    Writeln('Stroke Weight             ',FD[24],' ',Temp);
  269.  
  270.    Case FD[25] of
  271.         0 : Temp := 'Line Printer';
  272.         3 : Temp := 'Courier';
  273.         4 : Temp := 'Helvetica';
  274.         5 : Temp := 'Times Roman';
  275.         6 : Temp := 'Letter Gothic';
  276.         8 : Temp := 'Prestige';
  277.        11 : Temp := 'Presentations';
  278.        17 : Temp := 'Optima';
  279.        18 : Temp := 'Garamond';
  280.        19 : Temp := 'Cooper Black';
  281.        20 : Temp := 'Coronet Bold';
  282.        21 : Temp := 'Broadway';
  283.        22 : Temp := 'Bauer Bodoni Black Condensed';
  284.        23 : Temp := 'Century Schoolbook';
  285.        24 : Temp := 'University Roman';
  286.        else Temp := 'Unknown';
  287.    end;
  288.    Writeln('Typeface                  ',Temp);
  289.  
  290.    {Bytes 26 through 47 are not very interesting}
  291.  
  292.    Temp := '';
  293.    For Counter := 48 to 63                 {Font name area of descriptor}
  294.       do Temp := Temp + chr(FD[counter]);
  295.  
  296.    Writeln('Font Name                 ',Temp);
  297.  
  298.    If DecFD > 63 then                      {Display additional info, if any}
  299.       Begin
  300.    Write('Additional information    ');
  301.  
  302.          For Counter := 64 to (DecFD - 1) do  {Show "normal" characters only}
  303.            If (FD[counter] > 31) AND (FD[counter] < 126)
  304.               then Write(chr(FD[counter]));
  305.       end;
  306.    Writeln;
  307. End; {Descriptor}
  308.  
  309.  
  310.  
  311. Procedure Characters;
  312. Var
  313.    ReadByte : Byte;
  314.    Counter : Integer;
  315.    DecCD : Integer;       {DecCD = decimal value of char desc length}
  316.    Temp, S : String[20];
  317.    Calc : real;
  318.    CharStr : char;        {the character being described}
  319.    CharVal : integer;     {the ASCII value of the character}
  320.    TChar : char;          {Terminating character of the command}
  321.    CodeStr : String[3];   {Character string of the decimal ASCII for CharStr}
  322.  
  323. Procedure CharCode;       {sub-procedure of Procedure Characters}
  324. {With the file pointer positioned at the start of the bytes defining the
  325.  character code this procedure will determine the character CharSt and
  326.  the code CodeStr by looking for the terminating character and processing
  327.  the interveaning bytes. This is similar to Function DataSize}
  328.  
  329. Var
  330.    DataByte : byte;
  331.    ByteNum, NumofBytes, DecVal, Total, X, Y : Integer;
  332.    HexData : A6B;
  333.  
  334. Begin
  335.    ByteNum := 1;
  336.    DataByte := NextByte;
  337.  
  338.    {Find terminating character and fill the Hex data array}
  339.  
  340.    While  (Chr(DataByte) <> TChar) AND (ByteNum < 5) do
  341.       Begin
  342.          HexData[ByteNum] := DataByte;
  343.          DataByte := NextByte;
  344.          ByteNum := ByteNum + 1;
  345.       end;  {of While}
  346.    If ByteNum <  5 then                   {found correct character}
  347.       Begin
  348.          Total := 0;
  349.          NumofBytes := ByteNum -1;  {number of data bytes}
  350.                                     {last was due to reading the TermChar}
  351.  
  352.          For X := NumofBytes downto 1 do    {start with least signigicant}
  353.             Begin
  354.                DecVal := HexData[X] - 48;   {convert Hex to decimal character}
  355.                Y := NumofBytes - X;
  356.                Case Y of
  357.                    0 : Total := Total + DecVal;
  358.                    1 : Total := Total + 10 * DecVal;
  359.                    2 : Total := Total + 100 * DecVal;
  360.                 End  {of Case}
  361.            End;  {of For}
  362.            CharVal := Total;               {assign ASCII value to variable}
  363.            CharStr := chr(Total);          {assign character to variable}
  364.            CodeStr := '';
  365.            For X := 1 to NumofBytes do     {assign string to variable}
  366.               CodeStr := CodeStr + chr(HexData[X]);
  367.         end
  368.      Else  Error := true;          {too many bytes with out finding TermChar}
  369. End; {of Procedure CharCode}
  370.  
  371. Begin                                  {Actual start of Procedure Characters}
  372.    FindCmd('*c');                      {Look for Character Code command}
  373.    If Error
  374.       then
  375.         If GoodData                    {there was good stuff once}
  376.            then EndofFile := true      {no more good stuff, must be endoffile}
  377.            else                        {no good stuff first time, stop prog}
  378.               begin
  379.                  writeln('Character Code command not found');
  380.                  Halt;                  {Stops program with error message}
  381.               end
  382.       else GoodData := true;            {At least one char descriptor found}
  383.  
  384. If NOT EndofFile then begin             {loop around for end of file}
  385.  
  386.    TChar := 'E';                        {assign terminating character}
  387.    CharCode;                            {Find Character Code}
  388.    If NOT Error then
  389.          Begin
  390. {           Writeln('Character Code =',CharStr,'   Character is ',CodeStr);}
  391.          end
  392.       Else
  393.          Begin
  394.             Writeln('Character Code not found');
  395.             Halt;
  396.          end;
  397.  
  398.    FindCmd('(s');                {Look for Character Descriptor command}
  399.    If Error
  400.       then
  401.         begin
  402.            writeln('Character Descriptor command not found');
  403.            Halt;                 {Stops program with error message}
  404.         end;
  405.  
  406.    DecCD := DataSize('W');       {Find Character Descriptor data size}
  407.       If NOT Error then
  408.          Begin
  409. {           Writeln('Character Descriptor Length    ',DecCD,' bytes');}
  410.          end
  411.       Else
  412.          Begin
  413.             Writeln('Character Descriptor length not found');
  414.             Halt;                {Stops program with error message}
  415.          end;
  416.  
  417.    For Counter := 0 to 15
  418.       do CD[Counter] := NextByte;         {read char description}
  419.  
  420.    If CharVal < FirstChar then FirstChar := CharVal; {track first char}
  421.    If CharVal > LastChar then LastChar := CharVal;   {track last char}
  422.  
  423.    Calc := Int(CDW(14)/4);                {calculate width in dots}
  424.    Str(CharVal,S);                        {change char value to a string}
  425.    Temp := S + ':';                       {start building temp}
  426.    Str(Calc:1:0,S);                       {change calc value to a string}
  427.    Temp := Temp + S;                      {finish building string}
  428.    WidthData[CharVal] := Temp;            {put string in width data array}
  429.    GotoXY(30,23);                         {print on CRT to keep user happy}
  430.    Write(CharStr:3,' ',Temp:8);
  431.  
  432.    For Counter := 16 to (DecCD -1)
  433.       do ReadByte := NextByte;            {eat data bytes}
  434.  
  435. end; {of loop around for end of file}
  436.  
  437. End; {Procedure Characters}
  438.  
  439.  
  440.  
  441. Function BinY : boolean;    {inputs Y/N requiring a Y or y input to give true}
  442.     var                     {anything else returns false}
  443.       Inchar : char;
  444.     begin
  445.       Inchar := Readkey;
  446.       If (Inchar = 'y') or (Inchar = 'Y') then
  447.         BinY := true
  448.       Else
  449.         BinY := false;
  450.     end;
  451.  
  452.  
  453.  
  454. Procedure WidthTable;
  455. Var
  456.    Response : boolean;
  457.    FileName : S12;
  458.    Counter, X, Y : integer;
  459.    Calc : real;
  460.  
  461. Begin
  462.       Writeln;
  463.       Writeln('Character spacing is variable.');            {if variable}
  464.       Write('Would you like write a width table (Y/N)? ');  {ask about table}
  465.       Response := false;
  466.       Response := BinY;
  467.       Writeln;
  468.       If Response then
  469.          Begin
  470.             Write('Output File? ');        {Yes response, open file}
  471.             Readln(FileName);
  472.             Assign(OutFile, FileName);
  473.             Rewrite(OutFile);              {will over write file of same name}
  474.             FirstChar := 255;              {set first/last chars at extreme}
  475.             LastChar := 0;                 {note: this feature is not used
  476.                                             the table includes all characters}
  477.             For Counter := 0 to 255 do WidthData[Counter] := ''; {clear array}
  478.             While NOT EndofFile do Characters;     {get data on each char}
  479.  
  480.             Calc := Round(((FDW(18)/4)/300)*144);  {calc font size in ½points}
  481.             Writeln(Outfile,'FontSize:',Calc:1:0,' chFirst:', {1st line of}
  482.                              '1',' chLast:','255');  {table}
  483.             X := 0;
  484.             Y := Round(Calc/2 + 1);      {spaces and undefined characters}
  485.             For Counter := 1 to 255 do   {are 1/2 height + 1}
  486.                Begin
  487.                   If WidthData[Counter] <> '' then
  488.                      Write(Outfile,WidthData[Counter]:8)
  489.                      else Write(Outfile,Counter:5,':',Y:1);
  490.                 Inc(X);
  491.                 If X = 8 then                        {8 columns}
  492.                    Begin
  493.                      X := 0;
  494.                      Writeln(OutFile)               {next line}
  495.                    end;
  496.                End;
  497.             Writeln(Outfile);
  498.             Close(OutFile);
  499.          end;
  500. End; {Procedure WidthTable}
  501.  
  502.  
  503.  
  504. Begin
  505.    ClrScr;
  506.    Error := false;
  507.    EndofFile := false;
  508.    GoodData := false;
  509.    Openfiles;
  510.    Size := 0.0;
  511.    Descriptor;
  512.    If FD[13] = 1 then    {only ask about width table if variable spaced}
  513.       WidthTable;
  514.    Close(InFile);
  515. END.
  516.